home *** CD-ROM | disk | FTP | other *** search
/ Clickx 115 / Clickx 115.iso / software / tools / windows / tails-i386-0.16.iso / live / filesystem.squashfs / usr / share / tcltk / tk8.5 / console.tcl < prev    next >
Encoding:
Text File  |  2009-11-17  |  28.4 KB  |  1,056 lines
  1. # console.tcl --
  2. #
  3. # This code constructs the console window for an application.  It
  4. # can be used by non-unix systems that do not have built-in support
  5. # for shells.
  6. #
  7. # RCS: @(#) $Id: console.tcl,v 1.37.2.2 2009/04/10 16:29:18 das Exp $
  8. #
  9. # Copyright (c) 1995-1997 Sun Microsystems, Inc.
  10. # Copyright (c) 1998-2000 Ajuba Solutions.
  11. # Copyright (c) 2007 Daniel A. Steffen <das@users.sourceforge.net>
  12. #
  13. # See the file "license.terms" for information on usage and redistribution
  14. # of this file, and for a DISCLAIMER OF ALL WARRANTIES.
  15. #
  16.  
  17. # TODO: history - remember partially written command
  18.  
  19. namespace eval ::tk::console {
  20.     variable blinkTime   500 ; # msecs to blink braced range for
  21.     variable blinkRange  1   ; # enable blinking of the entire braced range
  22.     variable magicKeys   1   ; # enable brace matching and proc/var recognition
  23.     variable maxLines    600 ; # maximum # of lines buffered in console
  24.     variable showMatches 1   ; # show multiple expand matches
  25.  
  26.     variable inPlugin [info exists embed_args]
  27.     variable defaultPrompt   ; # default prompt if tcl_prompt1 isn't used
  28.  
  29.  
  30.     if {$inPlugin} {
  31.     set defaultPrompt {subst {[history nextid] % }}
  32.     } else {
  33.     set defaultPrompt {subst {([file tail [pwd]]) [history nextid] % }}
  34.     }
  35. }
  36.  
  37. # simple compat function for tkcon code added for this console
  38. interp alias {} EvalAttached {} consoleinterp eval
  39.  
  40. # ::tk::ConsoleInit --
  41. # This procedure constructs and configures the console windows.
  42. #
  43. # Arguments:
  44. #     None.
  45.  
  46. proc ::tk::ConsoleInit {} {
  47.     global tcl_platform
  48.  
  49.     if {![consoleinterp eval {set tcl_interactive}]} {
  50.     wm withdraw .
  51.     }
  52.  
  53.     if {[tk windowingsystem] eq "aqua"} {
  54.     set mod "Cmd"
  55.     } else {
  56.     set mod "Ctrl"
  57.     }
  58.  
  59.     if {[catch {menu .menubar} err]} {
  60.     bgerror "INIT: $err"
  61.     }
  62.     AmpMenuArgs .menubar add cascade -label [mc &File] -menu .menubar.file
  63.     AmpMenuArgs .menubar add cascade -label [mc &Edit] -menu .menubar.edit
  64.  
  65.     menu .menubar.file -tearoff 0
  66.     AmpMenuArgs .menubar.file add command -label [mc "&Source..."] \
  67.         -command {tk::ConsoleSource}
  68.     AmpMenuArgs .menubar.file add command -label [mc "&Hide Console"] \
  69.         -command {wm withdraw .}
  70.     AmpMenuArgs .menubar.file add command -label [mc "&Clear Console"] \
  71.         -command {.console delete 1.0 "promptEnd linestart"}
  72.     if {[tk windowingsystem] ne "aqua"} {
  73.     AmpMenuArgs .menubar.file add command -label [mc E&xit] -command {exit}
  74.     }
  75.  
  76.     menu .menubar.edit -tearoff 0
  77.     AmpMenuArgs    .menubar.edit add command -label [mc Cu&t]   -accel "$mod+X"\
  78.         -command {event generate .console <<Cut>>}
  79.     AmpMenuArgs    .menubar.edit add command -label [mc &Copy]  -accel "$mod+C"\
  80.         -command {event generate .console <<Copy>>}
  81.     AmpMenuArgs    .menubar.edit add command -label [mc P&aste] -accel "$mod+V"\
  82.         -command {event generate .console <<Paste>>}
  83.  
  84.     if {$tcl_platform(platform) ne "windows"} {
  85.     AmpMenuArgs .menubar.edit add command -label [mc Cl&ear] \
  86.         -command {event generate .console <<Clear>>}
  87.     } else {
  88.     AmpMenuArgs .menubar.edit add command -label [mc &Delete] \
  89.         -command {event generate .console <<Clear>>} -accel "Del"
  90.  
  91.     AmpMenuArgs .menubar add cascade -label [mc &Help] -menu .menubar.help
  92.     menu .menubar.help -tearoff 0
  93.     AmpMenuArgs .menubar.help add command -label [mc &About...] \
  94.         -command tk::ConsoleAbout
  95.     }
  96.  
  97.     AmpMenuArgs .menubar.edit add separator
  98.     AmpMenuArgs .menubar.edit add command -label [mc "&Increase Font Size"] \
  99.         -accel "$mod++" -command {event generate .console <<Console_FontSizeIncr>>}
  100.     AmpMenuArgs .menubar.edit add command -label [mc "&Decrease Font Size"] \
  101.         -accel "$mod+-" -command {event generate .console <<Console_FontSizeDecr>>}
  102.  
  103.     . configure -menu .menubar
  104.  
  105.     # See if we can find a better font than the TkFixedFont
  106.     catch {font create TkConsoleFont {*}[font configure TkFixedFont]}
  107.     set families [font families]
  108.     switch -exact -- [tk windowingsystem] {
  109.         aqua { set preferred {Monaco 10} }
  110.         win32 { set preferred {ProFontWindows 8 Consolas 8} }
  111.         default { set preferred {} }
  112.     }
  113.     foreach {family size} $preferred {
  114.         if {[lsearch -exact $families $family] != -1} {
  115.             font configure TkConsoleFont -family $family -size $size
  116.             break
  117.         }
  118.     }
  119.  
  120.     # Provide the right border for the text widget (platform dependent).
  121.     ::ttk::style layout ConsoleFrame {
  122.         Entry.field -sticky news -border 1 -children {
  123.             ConsoleFrame.padding -sticky news
  124.         }
  125.     }
  126.     ::ttk::frame .consoleframe -style ConsoleFrame
  127.  
  128.     set con [text .console -yscrollcommand [list .sb set] -setgrid true \
  129.                  -borderwidth 0 -highlightthickness 0 -font TkConsoleFont]
  130.     if {[tk windowingsystem] eq "aqua"} {
  131.         scrollbar .sb -command [list $con yview]
  132.     } else {
  133.         ::ttk::scrollbar .sb -command [list $con yview]
  134.     }
  135.     pack .sb  -in .consoleframe -fill both -side right -padx 1 -pady 1
  136.     pack $con -in .consoleframe -fill both -expand 1 -side left -padx 1 -pady 1
  137.     pack .consoleframe -fill both -expand 1 -side left
  138.  
  139.     ConsoleBind $con
  140.  
  141.     $con tag configure stderr    -foreground red
  142.     $con tag configure stdin    -foreground blue
  143.     $con tag configure prompt    -foreground \#8F4433
  144.     $con tag configure proc    -foreground \#008800
  145.     $con tag configure var    -background \#FFC0D0
  146.     $con tag raise sel
  147.     $con tag configure blink    -background \#FFFF00
  148.     $con tag configure find    -background \#FFFF00
  149.  
  150.     focus $con
  151.  
  152.     # Avoid listing this console in [winfo interps]
  153.     if {[info command ::send] eq "::send"} {rename ::send {}}
  154.  
  155.     wm protocol . WM_DELETE_WINDOW { wm withdraw . }
  156.     wm title . [mc "Console"]
  157.     flush stdout
  158.     $con mark set output [$con index "end - 1 char"]
  159.     tk::TextSetCursor $con end
  160.     $con mark set promptEnd insert
  161.     $con mark gravity promptEnd left
  162.  
  163.     # A variant of ConsolePrompt to avoid a 'puts' call
  164.     set w $con
  165.     set temp [$w index "end - 1 char"]
  166.     $w mark set output end
  167.     if {![consoleinterp eval "info exists tcl_prompt1"]} {
  168.     set string [EvalAttached $::tk::console::defaultPrompt]
  169.     $w insert output $string stdout
  170.     }
  171.     $w mark set output $temp
  172.     ::tk::TextSetCursor $w end
  173.     $w mark set promptEnd insert
  174.     $w mark gravity promptEnd left
  175.  
  176.     if {$tcl_platform(platform) eq "windows"} {
  177.     # Subtle work-around to erase the '% ' that tclMain.c prints out
  178.     after idle [subst -nocommand {
  179.         if {[$con get 1.0 output] eq "% "} { $con delete 1.0 output }
  180.     }]
  181.     }
  182. }
  183.  
  184. # ::tk::ConsoleSource --
  185. #
  186. # Prompts the user for a file to source in the main interpreter.
  187. #
  188. # Arguments:
  189. # None.
  190.  
  191. proc ::tk::ConsoleSource {} {
  192.     set filename [tk_getOpenFile -defaultextension .tcl -parent . \
  193.         -title [mc "Select a file to source"] \
  194.         -filetypes [list \
  195.         [list [mc "Tcl Scripts"] .tcl] \
  196.         [list [mc "All Files"] *]]]
  197.     if {$filename ne ""} {
  198.         set cmd [list source $filename]
  199.     if {[catch {consoleinterp eval $cmd} result]} {
  200.         ConsoleOutput stderr "$result\n"
  201.     }
  202.     }
  203. }
  204.  
  205. # ::tk::ConsoleInvoke --
  206. # Processes the command line input.  If the command is complete it
  207. # is evaled in the main interpreter.  Otherwise, the continuation
  208. # prompt is added and more input may be added.
  209. #
  210. # Arguments:
  211. # None.
  212.  
  213. proc ::tk::ConsoleInvoke {args} {
  214.     set ranges [.console tag ranges input]
  215.     set cmd ""
  216.     if {[llength $ranges]} {
  217.     set pos 0
  218.     while {[lindex $ranges $pos] ne ""} {
  219.         set start [lindex $ranges $pos]
  220.         set end [lindex $ranges [incr pos]]
  221.         append cmd [.console get $start $end]
  222.         incr pos
  223.     }
  224.     }
  225.     if {$cmd eq ""} {
  226.     ConsolePrompt
  227.     } elseif {[info complete $cmd]} {
  228.     .console mark set output end
  229.     .console tag delete input
  230.     set result [consoleinterp record $cmd]
  231.     if {$result ne ""} {
  232.         puts $result
  233.     }
  234.     ConsoleHistory reset
  235.     ConsolePrompt
  236.     } else {
  237.     ConsolePrompt partial
  238.     }
  239.     .console yview -pickplace insert
  240. }
  241.  
  242. # ::tk::ConsoleHistory --
  243. # This procedure implements command line history for the
  244. # console.  In general is evals the history command in the
  245. # main interpreter to obtain the history.  The variable
  246. # ::tk::HistNum is used to store the current location in the history.
  247. #
  248. # Arguments:
  249. # cmd -    Which action to take: prev, next, reset.
  250.  
  251. set ::tk::HistNum 1
  252. proc ::tk::ConsoleHistory {cmd} {
  253.     variable HistNum
  254.  
  255.     switch $cmd {
  256.         prev {
  257.         incr HistNum -1
  258.         if {$HistNum == 0} {
  259.         set cmd {history event [expr {[history nextid] -1}]}
  260.         } else {
  261.         set cmd "history event $HistNum"
  262.         }
  263.             if {[catch {consoleinterp eval $cmd} cmd]} {
  264.                 incr HistNum
  265.                 return
  266.             }
  267.         .console delete promptEnd end
  268.             .console insert promptEnd $cmd {input stdin}
  269.         }
  270.         next {
  271.         incr HistNum
  272.         if {$HistNum == 0} {
  273.         set cmd {history event [expr {[history nextid] -1}]}
  274.         } elseif {$HistNum > 0} {
  275.         set cmd ""
  276.         set HistNum 1
  277.         } else {
  278.         set cmd "history event $HistNum"
  279.         }
  280.         if {$cmd ne ""} {
  281.         catch {consoleinterp eval $cmd} cmd
  282.         }
  283.         .console delete promptEnd end
  284.         .console insert promptEnd $cmd {input stdin}
  285.         }
  286.         reset {
  287.             set HistNum 1
  288.         }
  289.     }
  290. }
  291.  
  292. # ::tk::ConsolePrompt --
  293. # This procedure draws the prompt.  If tcl_prompt1 or tcl_prompt2
  294. # exists in the main interpreter it will be called to generate the 
  295. # prompt.  Otherwise, a hard coded default prompt is printed.
  296. #
  297. # Arguments:
  298. # partial -    Flag to specify which prompt to print.
  299.  
  300. proc ::tk::ConsolePrompt {{partial normal}} {
  301.     set w .console
  302.     if {$partial eq "normal"} {
  303.     set temp [$w index "end - 1 char"]
  304.     $w mark set output end
  305.         if {[consoleinterp eval "info exists tcl_prompt1"]} {
  306.             consoleinterp eval "eval \[set tcl_prompt1\]"
  307.         } else {
  308.             puts -nonewline [EvalAttached $::tk::console::defaultPrompt]
  309.         }
  310.     } else {
  311.     set temp [$w index output]
  312.     $w mark set output end
  313.         if {[consoleinterp eval "info exists tcl_prompt2"]} {
  314.             consoleinterp eval "eval \[set tcl_prompt2\]"
  315.         } else {
  316.         puts -nonewline "> "
  317.         }
  318.     }
  319.     flush stdout
  320.     $w mark set output $temp
  321.     ::tk::TextSetCursor $w end
  322.     $w mark set promptEnd insert
  323.     $w mark gravity promptEnd left
  324.     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
  325.     $w see end
  326. }
  327.  
  328. # ::tk::ConsoleBind --
  329. # This procedure first ensures that the default bindings for the Text
  330. # class have been defined.  Then certain bindings are overridden for
  331. # the class.
  332. #
  333. # Arguments:
  334. # None.
  335.  
  336. proc ::tk::ConsoleBind {w} {
  337.     bindtags $w [list $w Console PostConsole [winfo toplevel $w] all]
  338.  
  339.     ## Get all Text bindings into Console
  340.     foreach ev [bind Text] {
  341.     bind Console $ev [bind Text $ev]
  342.     }
  343.     ## We really didn't want the newline insertion...
  344.     bind Console <Control-Key-o> {}
  345.     ## ...or any Control-v binding (would block <<Paste>>)
  346.     bind Console <Control-Key-v> {}
  347.  
  348.     # For the moment, transpose isn't enabled until the console
  349.     # gets and overhaul of how it handles input -- hobbs
  350.     bind Console <Control-Key-t> {}
  351.  
  352.     # Ignore all Alt, Meta, and Control keypresses unless explicitly bound.
  353.     # Otherwise, if a widget binding for one of these is defined, the
  354.  
  355.     bind Console <Alt-KeyPress> {# nothing }
  356.     bind Console <Meta-KeyPress> {# nothing}
  357.     bind Console <Control-KeyPress> {# nothing}
  358.  
  359.     foreach {ev key} {
  360.     <<Console_Prev>>        <Key-Up>
  361.     <<Console_Next>>        <Key-Down>
  362.     <<Console_NextImmediate>>    <Control-Key-n>
  363.     <<Console_PrevImmediate>>    <Control-Key-p>
  364.     <<Console_PrevSearch>>        <Control-Key-r>
  365.     <<Console_NextSearch>>        <Control-Key-s>
  366.  
  367.     <<Console_Expand>>        <Key-Tab>
  368.     <<Console_Expand>>        <Key-Escape>
  369.     <<Console_ExpandFile>>        <Control-Shift-Key-F>
  370.     <<Console_ExpandProc>>        <Control-Shift-Key-P>
  371.     <<Console_ExpandVar>>        <Control-Shift-Key-V>
  372.     <<Console_Tab>>            <Control-Key-i>
  373.     <<Console_Tab>>            <Meta-Key-i>
  374.     <<Console_Eval>>        <Key-Return>
  375.     <<Console_Eval>>        <Key-KP_Enter>
  376.  
  377.     <<Console_Clear>>        <Control-Key-l>
  378.     <<Console_KillLine>>        <Control-Key-k>
  379.     <<Console_Transpose>>        <Control-Key-t>
  380.     <<Console_ClearLine>>        <Control-Key-u>
  381.     <<Console_SaveCommand>>        <Control-Key-z>
  382.         <<Console_FontSizeIncr>>    <Control-Key-plus>
  383.         <<Console_FontSizeDecr>>    <Control-Key-minus>
  384.     } {
  385.     event add $ev $key
  386.     bind Console $key {}
  387.     }
  388.     if {[tk windowingsystem] eq "aqua"} {
  389.     foreach {ev key} {
  390.         <<Console_FontSizeIncr>>    <Command-Key-plus>
  391.         <<Console_FontSizeDecr>>    <Command-Key-minus>
  392.     } {
  393.         event add $ev $key
  394.         bind Console $key {}
  395.     }
  396.     }
  397.     bind Console <<Console_Expand>> {
  398.     if {[%W compare insert > promptEnd]} {
  399.         ::tk::console::Expand %W
  400.     }
  401.     }
  402.     bind Console <<Console_ExpandFile>> {
  403.     if {[%W compare insert > promptEnd]} {
  404.         ::tk::console::Expand %W path
  405.     }
  406.     }
  407.     bind Console <<Console_ExpandProc>> {
  408.     if {[%W compare insert > promptEnd]} {
  409.         ::tk::console::Expand %W proc
  410.     }
  411.     }
  412.     bind Console <<Console_ExpandVar>> {
  413.     if {[%W compare insert > promptEnd]} {
  414.         ::tk::console::Expand %W var
  415.     }
  416.     }
  417.     bind Console <<Console_Eval>> {
  418.     %W mark set insert {end - 1c}
  419.     tk::ConsoleInsert %W "\n"
  420.     tk::ConsoleInvoke
  421.     break
  422.     }
  423.     bind Console <Delete> {
  424.     if {{} ne [%W tag nextrange sel 1.0 end] \
  425.         && [%W compare sel.first >= promptEnd]} {
  426.         %W delete sel.first sel.last
  427.     } elseif {[%W compare insert >= promptEnd]} {
  428.         %W delete insert
  429.         %W see insert
  430.     }
  431.     }
  432.     bind Console <BackSpace> {
  433.     if {{} ne [%W tag nextrange sel 1.0 end] \
  434.         && [%W compare sel.first >= promptEnd]} {
  435.         %W delete sel.first sel.last
  436.     } elseif {[%W compare insert != 1.0] && \
  437.         [%W compare insert > promptEnd]} {
  438.         %W delete insert-1c
  439.         %W see insert
  440.     }
  441.     }
  442.     bind Console <Control-h> [bind Console <BackSpace>]
  443.  
  444.     bind Console <Home> {
  445.     if {[%W compare insert < promptEnd]} {
  446.         tk::TextSetCursor %W {insert linestart}
  447.     } else {
  448.         tk::TextSetCursor %W promptEnd
  449.     }
  450.     }
  451.     bind Console <Control-a> [bind Console <Home>]
  452.     bind Console <End> {
  453.     tk::TextSetCursor %W {insert lineend}
  454.     }
  455.     bind Console <Control-e> [bind Console <End>]
  456.     bind Console <Control-d> {
  457.     if {[%W compare insert < promptEnd]} {
  458.         break
  459.     }
  460.     %W delete insert
  461.     }
  462.     bind Console <<Console_KillLine>> {
  463.     if {[%W compare insert < promptEnd]} {
  464.         break
  465.     }
  466.     if {[%W compare insert == {insert lineend}]} {
  467.         %W delete insert
  468.     } else {
  469.         %W delete insert {insert lineend}
  470.     }
  471.     }
  472.     bind Console <<Console_Clear>> {
  473.     ## Clear console display
  474.     %W delete 1.0 "promptEnd linestart"
  475.     }
  476.     bind Console <<Console_ClearLine>> {
  477.     ## Clear command line (Unix shell staple)
  478.     %W delete promptEnd end
  479.     }
  480.     bind Console <Meta-d> {
  481.     if {[%W compare insert >= promptEnd]} {
  482.         %W delete insert {insert wordend}
  483.     }
  484.     }
  485.     bind Console <Meta-BackSpace> {
  486.     if {[%W compare {insert -1c wordstart} >= promptEnd]} {
  487.         %W delete {insert -1c wordstart} insert
  488.     }
  489.     }
  490.     bind Console <Meta-d> {
  491.     if {[%W compare insert >= promptEnd]} {
  492.         %W delete insert {insert wordend}
  493.     }
  494.     }
  495.     bind Console <Meta-BackSpace> {
  496.     if {[%W compare {insert -1c wordstart} >= promptEnd]} {
  497.         %W delete {insert -1c wordstart} insert
  498.     }
  499.     }
  500.     bind Console <Meta-Delete> {
  501.     if {[%W compare insert >= promptEnd]} {
  502.         %W delete insert {insert wordend}
  503.     }
  504.     }
  505.     bind Console <<Console_Prev>> {
  506.     tk::ConsoleHistory prev
  507.     }
  508.     bind Console <<Console_Next>> {
  509.     tk::ConsoleHistory next
  510.     }
  511.     bind Console <Insert> {
  512.     catch {tk::ConsoleInsert %W [::tk::GetSelection %W PRIMARY]}
  513.     }
  514.     bind Console <KeyPress> {
  515.     tk::ConsoleInsert %W %A
  516.     }
  517.     bind Console <F9> {
  518.     eval destroy [winfo child .]
  519.     source [file join $tk_library console.tcl]
  520.     }
  521.     if {[tk windowingsystem] eq "aqua"} {
  522.     bind Console <Command-q> {
  523.         exit
  524.     }
  525.     }
  526.     bind Console <<Cut>> {
  527.         # Same as the copy event
  528.      if {![catch {set data [%W get sel.first sel.last]}]} {
  529.         clipboard clear -displayof %W
  530.         clipboard append -displayof %W $data
  531.     }
  532.     }
  533.     bind Console <<Copy>> {
  534.      if {![catch {set data [%W get sel.first sel.last]}]} {
  535.         clipboard clear -displayof %W
  536.         clipboard append -displayof %W $data
  537.     }
  538.     }
  539.     bind Console <<Paste>> {
  540.     catch {
  541.         set clip [::tk::GetSelection %W CLIPBOARD]
  542.         set list [split $clip \n\r]
  543.         tk::ConsoleInsert %W [lindex $list 0]
  544.         foreach x [lrange $list 1 end] {
  545.         %W mark set insert {end - 1c}
  546.         tk::ConsoleInsert %W "\n"
  547.         tk::ConsoleInvoke
  548.         tk::ConsoleInsert %W $x
  549.         }
  550.     }
  551.     }
  552.     bind Console <<Console_FontSizeIncr>> {
  553.         set size [font configure TkConsoleFont -size]
  554.         font configure TkConsoleFont -size [incr size]
  555.     }
  556.     bind Console <<Console_FontSizeDecr>> {
  557.         set size [font configure TkConsoleFont -size]
  558.         font configure TkConsoleFont -size [incr size -1]
  559.     }
  560.  
  561.     ##
  562.     ## Bindings for doing special things based on certain keys
  563.     ##
  564.     bind PostConsole <Key-parenright> {
  565.     if {"\\" ne [%W get insert-2c]} {
  566.         ::tk::console::MatchPair %W \( \) promptEnd
  567.     }
  568.     }
  569.     bind PostConsole <Key-bracketright> {
  570.     if {"\\" ne [%W get insert-2c]} {
  571.         ::tk::console::MatchPair %W \[ \] promptEnd
  572.     }
  573.     }
  574.     bind PostConsole <Key-braceright> {
  575.     if {"\\" ne [%W get insert-2c]} {
  576.         ::tk::console::MatchPair %W \{ \} promptEnd
  577.     }
  578.     }
  579.     bind PostConsole <Key-quotedbl> {
  580.     if {"\\" ne [%W get insert-2c]} {
  581.         ::tk::console::MatchQuote %W promptEnd
  582.     }
  583.     }
  584.  
  585.     bind PostConsole <KeyPress> {
  586.     if {"%A" ne ""} {
  587.         ::tk::console::TagProc %W
  588.     }
  589.     break
  590.     }
  591. }
  592.  
  593. # ::tk::ConsoleInsert --
  594. # Insert a string into a text at the point of the insertion cursor.
  595. # If there is a selection in the text, and it covers the point of the
  596. # insertion cursor, then delete the selection before inserting.  Insertion
  597. # is restricted to the prompt area.
  598. #
  599. # Arguments:
  600. # w -        The text window in which to insert the string
  601. # s -        The string to insert (usually just a single character)
  602.  
  603. proc ::tk::ConsoleInsert {w s} {
  604.     if {$s eq ""} {
  605.     return
  606.     }
  607.     catch {
  608.     if {[$w compare sel.first <= insert] \
  609.         && [$w compare sel.last >= insert]} {
  610.         $w tag remove sel sel.first promptEnd
  611.         $w delete sel.first sel.last
  612.     }
  613.     }
  614.     if {[$w compare insert < promptEnd]} {
  615.     $w mark set insert end
  616.     }
  617.     $w insert insert $s {input stdin}
  618.     $w see insert
  619. }
  620.  
  621. # ::tk::ConsoleOutput --
  622. #
  623. # This routine is called directly by ConsolePutsCmd to cause a string
  624. # to be displayed in the console.
  625. #
  626. # Arguments:
  627. # dest -    The output tag to be used: either "stderr" or "stdout".
  628. # string -    The string to be displayed.
  629.  
  630. proc ::tk::ConsoleOutput {dest string} {
  631.     set w .console
  632.     $w insert output $string $dest
  633.     ::tk::console::ConstrainBuffer $w $::tk::console::maxLines
  634.     $w see insert
  635. }
  636.  
  637. # ::tk::ConsoleExit --
  638. #
  639. # This routine is called by ConsoleEventProc when the main window of
  640. # the application is destroyed.  Don't call exit - that probably already
  641. # happened.  Just delete our window.
  642. #
  643. # Arguments:
  644. # None.
  645.  
  646. proc ::tk::ConsoleExit {} {
  647.     destroy .
  648. }
  649.  
  650. # ::tk::ConsoleAbout --
  651. #
  652. # This routine displays an About box to show Tcl/Tk version info.
  653. #
  654. # Arguments:
  655. # None.
  656.  
  657. proc ::tk::ConsoleAbout {} {
  658.     tk_messageBox -type ok -message "[mc {Tcl for Windows}]
  659.  
  660. Tcl $::tcl_patchLevel
  661. Tk $::tk_patchLevel"
  662. }
  663.  
  664. # ::tk::console::TagProc --
  665. #
  666. # Tags a procedure in the console if it's recognized
  667. # This procedure is not perfect.  However, making it perfect wastes
  668. # too much CPU time...
  669. #
  670. # Arguments:
  671. #    w    - console text widget
  672.  
  673. proc ::tk::console::TagProc w {
  674.     if {!$::tk::console::magicKeys} {
  675.     return
  676.     }
  677.     set exp "\[^\\\\\]\[\[ \t\n\r\;{}\"\$\]"
  678.     set i [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  679.     if {$i eq ""} {
  680.     set i promptEnd
  681.     } else {
  682.     append i +2c
  683.     }
  684.     regsub -all "\[\[\\\\\\?\\*\]" [$w get $i "insert-1c wordend"] {\\\0} c
  685.     if {[llength [EvalAttached [list info commands $c]]]} {
  686.     $w tag add proc $i "insert-1c wordend"
  687.     } else {
  688.     $w tag remove proc $i "insert-1c wordend"
  689.     }
  690.     if {[llength [EvalAttached [list info vars $c]]]} {
  691.     $w tag add var $i "insert-1c wordend"
  692.     } else {
  693.     $w tag remove var $i "insert-1c wordend"
  694.     }
  695. }
  696.  
  697. # ::tk::console::MatchPair --
  698. #
  699. # Blinks a matching pair of characters
  700. # c2 is assumed to be at the text index 'insert'.
  701. # This proc is really loopy and took me an hour to figure out given
  702. # all possible combinations with escaping except for escaped \'s.
  703. # It doesn't take into account possible commenting... Oh well.  If
  704. # anyone has something better, I'd like to see/use it.  This is really
  705. # only efficient for small contexts.
  706. #
  707. # Arguments:
  708. #    w    - console text widget
  709. #     c1    - first char of pair
  710. #     c2    - second char of pair
  711. #
  712. # Calls:    ::tk::console::Blink
  713.  
  714. proc ::tk::console::MatchPair {w c1 c2 {lim 1.0}} {
  715.     if {!$::tk::console::magicKeys} {
  716.     return
  717.     }
  718.     if {{} ne [set ix [$w search -back $c1 insert $lim]]} {
  719.     while {
  720.         [string match {\\} [$w get $ix-1c]] &&
  721.         [set ix [$w search -back $c1 $ix-1c $lim]] ne {}
  722.     } {}
  723.     set i1 insert-1c
  724.     while {$ix ne {}} {
  725.         set i0 $ix
  726.         set j 0
  727.         while {[set i0 [$w search $c2 $i0 $i1]] ne {}} {
  728.         append i0 +1c
  729.         if {[string match {\\} [$w get $i0-2c]]} {
  730.             continue
  731.         }
  732.         incr j
  733.         }
  734.         if {!$j} {
  735.         break
  736.         }
  737.         set i1 $ix
  738.         while {$j && [set ix [$w search -back $c1 $ix $lim]] ne {}} {
  739.         if {[string match {\\} [$w get $ix-1c]]} {
  740.             continue
  741.         }
  742.         incr j -1
  743.         }
  744.     }
  745.     if {[string match {} $ix]} {
  746.         set ix [$w index $lim]
  747.     }
  748.     } else {
  749.     set ix [$w index $lim]
  750.     }
  751.     if {$::tk::console::blinkRange} {
  752.     Blink $w $ix [$w index insert]
  753.     } else {
  754.     Blink $w $ix $ix+1c [$w index insert-1c] [$w index insert]
  755.     }
  756. }
  757.  
  758. # ::tk::console::MatchQuote --
  759. #
  760. # Blinks between matching quotes.
  761. # Blinks just the quote if it's unmatched, otherwise blinks quoted string
  762. # The quote to match is assumed to be at the text index 'insert'.
  763. #
  764. # Arguments:
  765. #    w    - console text widget
  766. #
  767. # Calls:    ::tk::console::Blink
  768.  
  769. proc ::tk::console::MatchQuote {w {lim 1.0}} {
  770.     if {!$::tk::console::magicKeys} {
  771.     return
  772.     }
  773.     set i insert-1c
  774.     set j 0
  775.     while {[set i [$w search -back \" $i $lim]] ne {}} {
  776.     if {[string match {\\} [$w get $i-1c]]} {
  777.         continue
  778.     }
  779.     if {!$j} {
  780.         set i0 $i
  781.     }
  782.     incr j
  783.     }
  784.     if {$j&1} {
  785.     if {$::tk::console::blinkRange} {
  786.         Blink $w $i0 [$w index insert]
  787.     } else {
  788.         Blink $w $i0 $i0+1c [$w index insert-1c] [$w index insert]
  789.     }
  790.     } else {
  791.     Blink $w [$w index insert-1c] [$w index insert]
  792.     }
  793. }
  794.  
  795. # ::tk::console::Blink --
  796. #
  797. # Blinks between n index pairs for a specified duration.
  798. #
  799. # Arguments:
  800. #    w    - console text widget
  801. #     i1    - start index to blink region
  802. #     i2    - end index of blink region
  803. #     dur    - duration in usecs to blink for
  804. #
  805. # Outputs:
  806. #    blinks selected characters in $w
  807.  
  808. proc ::tk::console::Blink {w args} {
  809.     eval [list $w tag add blink] $args
  810.     after $::tk::console::blinkTime [list $w] tag remove blink $args
  811. }
  812.  
  813. # ::tk::console::ConstrainBuffer --
  814. #
  815. # This limits the amount of data in the text widget
  816. # Called by Prompt and ConsoleOutput
  817. #
  818. # Arguments:
  819. #    w    - console text widget
  820. #    size    - # of lines to constrain to
  821. #
  822. # Outputs:
  823. #    may delete data in console widget
  824.  
  825. proc ::tk::console::ConstrainBuffer {w size} {
  826.     if {[$w index end] > $size} {
  827.     $w delete 1.0 [expr {int([$w index end])-$size}].0
  828.     }
  829. }
  830.  
  831. # ::tk::console::Expand --
  832. #
  833. # Arguments:
  834. # ARGS:    w    - text widget in which to expand str
  835. #     type    - type of expansion (path / proc / variable)
  836. #
  837. # Calls:    ::tk::console::Expand(Pathname|Procname|Variable)
  838. #
  839. # Outputs:    The string to match is expanded to the longest possible match.
  840. #        If ::tk::console::showMatches is non-zero and the longest match
  841. #        equaled the string to expand, then all possible matches are
  842. #        output to stdout.  Triggers bell if no matches are found.
  843. #
  844. # Returns:    number of matches found
  845.  
  846. proc ::tk::console::Expand {w {type ""}} {
  847.     set exp "\[^\\\\\]\[\[ \t\n\r\\\{\"\\\\\$\]"
  848.     set tmp [$w search -backwards -regexp $exp insert-1c promptEnd-1c]
  849.     if {$tmp eq ""} {
  850.     set tmp promptEnd
  851.     } else {
  852.     append tmp +2c
  853.     }
  854.     if {[$w compare $tmp >= insert]} {
  855.     return
  856.     }
  857.     set str [$w get $tmp insert]
  858.     switch -glob $type {
  859.     path* {
  860.         set res [ExpandPathname $str]
  861.     }
  862.     proc* {
  863.         set res [ExpandProcname $str]
  864.     }
  865.     var* {
  866.         set res [ExpandVariable $str]
  867.     }
  868.     default {
  869.         set res {}
  870.         foreach t {Pathname Procname Variable} {
  871.         if {![catch {Expand$t $str} res] && ($res ne "")} {
  872.             break
  873.         }
  874.         }
  875.     }
  876.     }
  877.     set len [llength $res]
  878.     if {$len} {
  879.     set repl [lindex $res 0]
  880.     $w delete $tmp insert
  881.     $w insert $tmp $repl {input stdin}
  882.     if {($len > 1) && ($::tk::console::showMatches) && ($repl eq $str)} {
  883.         puts stdout [lsort [lreplace $res 0 0]]
  884.     }
  885.     } else {
  886.     bell
  887.     }
  888.     return [incr len -1]
  889. }
  890.  
  891. # ::tk::console::ExpandPathname --
  892. #
  893. # Expand a file pathname based on $str
  894. # This is based on UNIX file name conventions
  895. #
  896. # Arguments:
  897. #    str    - partial file pathname to expand
  898. #
  899. # Calls:    ::tk::console::ExpandBestMatch
  900. #
  901. # Returns:    list containing longest unique match followed by all the
  902. #        possible further matches
  903.  
  904. proc ::tk::console::ExpandPathname str {
  905.     set pwd [EvalAttached pwd]
  906.     if {[catch {EvalAttached [list cd [file dirname $str]]} err]} {
  907.     return -code error $err
  908.     }
  909.     set dir [file tail $str]
  910.     ## Check to see if it was known to be a directory and keep the trailing
  911.     ## slash if so (file tail cuts it off)
  912.     if {[string match */ $str]} {
  913.     append dir /
  914.     }
  915.     if {[catch {lsort [EvalAttached [list glob $dir*]]} m]} {
  916.     set match {}
  917.     } else {
  918.     if {[llength $m] > 1} {
  919.         global tcl_platform
  920.         if {[string match windows $tcl_platform(platform)]} {
  921.         ## Windows is screwy because it's case insensitive
  922.         set tmp [ExpandBestMatch [string tolower $m] \
  923.             [string tolower $dir]]
  924.         ## Don't change case if we haven't changed the word
  925.         if {[string length $dir]==[string length $tmp]} {
  926.             set tmp $dir
  927.         }
  928.         } else {
  929.         set tmp [ExpandBestMatch $m $dir]
  930.         }
  931.         if {[string match ?*/* $str]} {
  932.         set tmp [file dirname $str]/$tmp
  933.         } elseif {[string match /* $str]} {
  934.         set tmp /$tmp
  935.         }
  936.         regsub -all { } $tmp {\\ } tmp
  937.         set match [linsert $m 0 $tmp]
  938.     } else {
  939.         ## This may look goofy, but it handles spaces in path names
  940.         eval append match $m
  941.         if {[file isdir $match]} {
  942.         append match /
  943.         }
  944.         if {[string match ?*/* $str]} {
  945.         set match [file dirname $str]/$match
  946.         } elseif {[string match /* $str]} {
  947.         set match /$match
  948.         }
  949.         regsub -all { } $match {\\ } match
  950.         ## Why is this one needed and the ones below aren't!!
  951.         set match [list $match]
  952.     }
  953.     }
  954.     EvalAttached [list cd $pwd]
  955.     return $match
  956. }
  957.  
  958. # ::tk::console::ExpandProcname --
  959. #
  960. # Expand a tcl proc name based on $str
  961. #
  962. # Arguments:
  963. #    str    - partial proc name to expand
  964. #
  965. # Calls:    ::tk::console::ExpandBestMatch
  966. #
  967. # Returns:    list containing longest unique match followed by all the
  968. #        possible further matches
  969.  
  970. proc ::tk::console::ExpandProcname str {
  971.     set match [EvalAttached [list info commands $str*]]
  972.     if {[llength $match] == 0} {
  973.     set ns [EvalAttached \
  974.         "namespace children \[namespace current\] [list $str*]"]
  975.     if {[llength $ns]==1} {
  976.         set match [EvalAttached [list info commands ${ns}::*]]
  977.     } else {
  978.         set match $ns
  979.     }
  980.     }
  981.     if {[llength $match] > 1} {
  982.     regsub -all { } [ExpandBestMatch $match $str] {\\ } str
  983.     set match [linsert $match 0 $str]
  984.     } else {
  985.     regsub -all { } $match {\\ } match
  986.     }
  987.     return $match
  988. }
  989.  
  990. # ::tk::console::ExpandVariable --
  991. #
  992. # Expand a tcl variable name based on $str
  993. #
  994. # Arguments:
  995. #    str    - partial tcl var name to expand
  996. #
  997. # Calls:    ::tk::console::ExpandBestMatch
  998. #
  999. # Returns:    list containing longest unique match followed by all the
  1000. #        possible further matches
  1001.  
  1002. proc ::tk::console::ExpandVariable str {
  1003.     if {[regexp {([^\(]*)\((.*)} $str -> ary str]} {
  1004.     ## Looks like they're trying to expand an array.
  1005.     set match [EvalAttached [list array names $ary $str*]]
  1006.     if {[llength $match] > 1} {
  1007.         set vars $ary\([ExpandBestMatch $match $str]
  1008.         foreach var $match {
  1009.         lappend vars $ary\($var\)
  1010.         }
  1011.         return $vars
  1012.     } elseif {[llength $match] == 1} {
  1013.         set match $ary\($match\)
  1014.     }
  1015.     ## Space transformation avoided for array names.
  1016.     } else {
  1017.     set match [EvalAttached [list info vars $str*]]
  1018.     if {[llength $match] > 1} {
  1019.         regsub -all { } [ExpandBestMatch $match $str] {\\ } str
  1020.         set match [linsert $match 0 $str]
  1021.     } else {
  1022.         regsub -all { } $match {\\ } match
  1023.     }
  1024.     }
  1025.     return $match
  1026. }
  1027.  
  1028. # ::tk::console::ExpandBestMatch --
  1029. #
  1030. # Finds the best unique match in a list of names.
  1031. # The extra $e in this argument allows us to limit the innermost loop a little
  1032. # further.  This improves speed as $l becomes large or $e becomes long.
  1033. #
  1034. # Arguments:
  1035. #    l    - list to find best unique match in
  1036. #     e    - currently best known unique match
  1037. #
  1038. # Returns:    longest unique match in the list
  1039.  
  1040. proc ::tk::console::ExpandBestMatch {l {e {}}} {
  1041.     set ec [lindex $l 0]
  1042.     if {[llength $l]>1} {
  1043.     set e [expr {[string length $e] - 1}]
  1044.     set ei [expr {[string length $ec] - 1}]
  1045.     foreach l $l {
  1046.         while {$ei>=$e && [string first $ec $l]} {
  1047.         set ec [string range $ec 0 [incr ei -1]]
  1048.         }
  1049.     }
  1050.     }
  1051.     return $ec
  1052. }
  1053.  
  1054. # now initialize the console
  1055. ::tk::ConsoleInit
  1056.